home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…stman Always Clicks Twice / ADC Developer CD (1993-01) (''The Postman Always Clicks Twice'')_iso / Dev.CD 199301.iso / Development Platforms / LISP Related / LISP Goodies / menu enhancements / make-menus.lisp < prev    next >
Encoding:
Text File  |  1992-09-02  |  3.2 KB  |  97 lines  |  [TEXT/CCL2]
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;make-menus.lisp
  3. ;;
  4. ;; Copyright © 1992 University of Toronto, Department of Computer Science
  5. ;; All Rights Reserved
  6. ;;
  7. ;; author: Mark A. Tapia
  8. ;;
  9. ;;  Defines the components of the menus package. Load this file after
  10. ;;  loading "init-menus".  Change the logical directory if the files
  11. ;;  are not stored in the subdirectory "ccl;menu enhancements:"
  12. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  13.  
  14. (unless (find-package :menu-enhancements)
  15.   (defpackage :menu-enhancements
  16.   (:use :common-lisp :ccl)
  17.   (:nicknames :menus)))
  18.  
  19. (in-package :menus)
  20. (require 'quickdraw)
  21. ;; mcl-final is true iff version is "Version 2.0f"
  22. (defparameter mcl-final cl-user::mcl-final)
  23. (in-package :menus)
  24. ;; change the directory to reflect your directory structure
  25.  
  26. ;; MCL2.0f uses logical-pathname-translations not def-logical-directory 
  27. (defparameter *menus-files* (list (format nil "~amarking-menu" cl-user::menu-dir) 
  28.                                   (format nil "~acheck-menu-item" cl-user::menu-dir)))
  29. (defparameter *menus-support-files* (list (format nil "~aoou-utils" cl-user::menu-dir)))
  30. (defparameter marking-demo (format nil "~amarking-demo" cl-user::menu-dir))
  31. (defparameter hier-demo (format nil "~ahier-demo" cl-user::menu-dir))
  32.  
  33. (defvar *loaded-menus-files* '())
  34.  
  35. (export '(load-menus load-marking-demo load-hier-demo) :menus)
  36.  
  37. (defun compile-if-changed (file always)
  38.   (let* ((source (merge-pathnames file ".lisp"))
  39.          (fasl (merge-pathnames file ".fasl")))
  40.     (unless (probe-file source)
  41.       (error "file not found: ~s" file))
  42.     (when (or always
  43.               (not (probe-file fasl))
  44.               (< (file-write-date fasl)
  45.                  (file-write-date source)))
  46.       (compile-file source :output-file fasl :verbose t))))
  47.  
  48. (defun load-if-changed (file always)
  49.   (compile-if-changed file nil)
  50.   (let* ((fasl (merge-pathnames file ".fasl"))
  51.          (date (file-write-date fasl))
  52.          (last-load (assoc file *loaded-menus-files* :test #'equalp)))
  53.     (when (or always
  54.               (not last-load)
  55.               (< (cdr last-load)
  56.                  date))
  57.       (load fasl :verbose t)
  58.       (if last-load
  59.           (setf (cdr last-load) date)
  60.           (push (cons file date) *loaded-menus-files*)))))
  61.  
  62. (defun compile-menus (&optional always)
  63.   (with-compilation-unit ()
  64.     (load-menus-support))
  65.   (with-compilation-unit ()
  66.     (dolist (file *menus-files*)
  67.       (compile-if-changed file always))))
  68.  
  69. ;(compile-menus)
  70. ;(compile-menus t)
  71.  
  72. (defun load-menus-support ()
  73.   (dolist (file *menus-support-files*)
  74.     (load-if-changed file nil)))
  75.  
  76. ;(load-menus-support)
  77.  
  78. (defun load-menus ()
  79.   (with-compilation-unit ()
  80.     (load-menus-support))
  81.   (with-compilation-unit ()
  82.     (dolist (file *menus-files*)
  83.       (load-if-changed file nil))))
  84.  
  85. (defun load-demos ()
  86.   (load-menus)
  87.   (with-compilation-unit ()
  88.     (load-if-changed "marking-menu-demo" nil)
  89.     (load-if-changed "hier-menu-demo" nil)))
  90.  
  91. #|
  92. (load-menus)                            ; to load the menus
  93. (load-demos)                            ; to load the marking-demo and hier-marking-demo
  94. (cl-user::marking-demo)                 ; to test the marking demo after loading
  95. (cl-user::hier-demo)                    ; to test the hier demo after loading
  96.  
  97. |#